home *** CD-ROM | disk | FTP | other *** search
/ MacFormat 1994 November / macformat-018.iso / Utility Spectacular / Developer / macgambit-20-compiler-src-p2 / Runtime (.scm & .s) / _ports.scm < prev    next >
Encoding:
Text File  |  1994-07-26  |  40.3 KB  |  1,172 lines  |  [TEXT/gamI]
  1. (##include "header.scm")
  2.  
  3. ;------------------------------------------------------------------------------
  4.  
  5. ; I/O stuff
  6.  
  7. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  8.  
  9. (define (##input-port? x)
  10.   (and (##subtyped? x)
  11.        (##fixnum.= (##subtype x) (subtype-port))
  12.        (##fixnum.< (##fixnum.modulo (port-kind x) 4) 2)))
  13.  
  14. (define (##output-port? x)
  15.   (and (##subtyped? x)
  16.        (##fixnum.= (##subtype x) (subtype-port))
  17.        (##fixnum.< 0 (##fixnum.modulo (port-kind x) 4))))
  18.  
  19. (define (##closed-port? x)
  20.   (and (##subtyped? x)
  21.        (##fixnum.= (##subtype x) (subtype-port))
  22.        (##fixnum.< 3 (port-kind x))))
  23.  
  24. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  25.  
  26. ; File I/O
  27.  
  28. (define (##make-port descr name kind read-proc write-proc ready-proc close-proc rbuf wbuf)
  29.   (let ((port (port-make)))
  30.     (port-kind-set!  port kind)
  31.     (port-name-set!  port name)
  32.     (port-read-set!  port (lambda (port)
  33.                             (let ((rbuf (port-rbuf port)))
  34.                               (let ((len (read-proc (port-misc port)
  35.                                                     rbuf
  36.                                                     0
  37.                                                     (##string-length rbuf))))
  38.                                 (if len
  39.                                   (begin
  40.                                     (port-pos-set! port 0)
  41.                                     (port-len-set! port len)
  42.                                     (##fixnum.= len 0))
  43.                                   (begin
  44.                                     (##signal '##SIGNAL.IO-ERROR "Read error on" port)
  45.                                     (port-pos-set! port 0)
  46.                                     (port-len-set! port 0)
  47.                                     #t))))))
  48.     (port-write-set! port (lambda (s i j port)
  49.                             (let loop ((i i))
  50.                               (let ((len (write-proc (port-misc port) s i j)))
  51.                                 (if len
  52.                                   (if (##fixnum.< 0 len)
  53.                                     (let ((i (##fixnum.+ len i)))
  54.                                       (if (##fixnum.< i j)
  55.                                         (loop i)))
  56.                                     (loop i))
  57.                                   (##signal '##SIGNAL.IO-ERROR "Write error on" port))))))
  58.     (port-ready-set! port (lambda (port) (ready-proc (port-misc port))))
  59.     (port-close-set! port (lambda (port)
  60.                             (if (##not (close-proc (port-misc port)))
  61.                               (##signal '##SIGNAL.IO-ERROR "Close error on" port))
  62.                             #t))
  63.     (port-pos-set!   port 0)
  64.     (port-len-set!   port 0)
  65.     (port-rbuf-set!  port rbuf)
  66.     (port-wbuf-set!  port wbuf)
  67.     (port-misc-set!  port descr)
  68.     port))
  69.  
  70. (define (##open-input-file s)
  71.   (let ((descr (##os-file-open-input s)))
  72.     (if descr
  73.       (##make-port descr s 0
  74.         ##os-file-read
  75.         #f
  76.         ##os-file-read-ready
  77.         ##os-file-close
  78.         (##make-string 64 #\space)
  79.         #f)
  80.       #f)))
  81.  
  82. (define (##open-output-file s)
  83.   (let ((descr (##os-file-open-output s)))
  84.     (if descr
  85.       (##make-port descr s 2
  86.         #f
  87.         ##os-file-write
  88.         #f
  89.         ##os-file-close
  90.         #f
  91.         (##make-string 1 #\space))
  92.       #f)))
  93.  
  94. (define (##open-input-output-file s)
  95.   (let ((descr (##os-file-open-input-output s)))
  96.     (if descr
  97.       (##make-port descr s 1
  98.         ##os-file-read
  99.         ##os-file-write
  100.         ##os-file-read-ready
  101.         ##os-file-close
  102.         (##make-string 64 #\space)
  103.         (##make-string 1 #\space))
  104.       #f)))
  105.  
  106. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  107.  
  108. ; String I/O
  109.  
  110. (define (##open-input-string str)
  111.   (let ((port (port-make)))
  112.     (port-kind-set!  port 0)
  113.     (port-name-set!  port 'STRING)
  114.     (port-read-set!  port (lambda (port) #t))
  115.     (port-write-set! port #f)
  116.     (port-ready-set! port (lambda (port) #t))
  117.     (port-close-set! port (lambda (port) #t))
  118.     (port-pos-set!   port 0)
  119.     (port-len-set!   port (##string-length str))
  120.     (port-rbuf-set!  port str)
  121.     (port-wbuf-set!  port #f)
  122.     port))
  123.  
  124. (define (##open-output-string)
  125.   (let ((port (port-make)))
  126.     (port-kind-set!  port 2)
  127.     (port-name-set!  port 'STRING)
  128.     (port-read-set!  port #f)
  129.     (port-write-set! port ##output-string-write)
  130.     (port-ready-set! port #f)
  131.     (port-close-set! port (lambda (port) #t))
  132.     (port-pos-set!   port 0)
  133.     (port-rbuf-set!  port #f)
  134.     (port-wbuf-set!  port (##make-string 1 #\space))
  135.     (port-misc-set!  port (##make-string 36 #\space)) ; 4 + 8*n
  136.     port))
  137.  
  138. (define (##output-string-write s i j port)
  139.   (let* ((str (port-misc port))
  140.          (pos (port-pos port))
  141.          (len (##string-length str))
  142.          (l (##fixnum.- j i))
  143.          (new-pos (##fixnum.+ pos l))
  144.          (overflow (##fixnum.- new-pos len)))
  145.     (if (##fixnum.< 0 overflow)
  146.       (let ((new-str (##make-string (##fixnum.+
  147.                                       (##fixnum.*
  148.                                         (##fixnum.quotient
  149.                                           (##fixnum.+ overflow 71)
  150.                                           8)
  151.                                         8)
  152.                                       len)
  153.                                     #\space)))
  154.         (let loop1 ((i (##fixnum.- pos 1)))
  155.           (if (##not (##fixnum.< i 0))
  156.             (begin
  157.               (##string-set! new-str i (##string-ref str i))
  158.               (loop1 (##fixnum.- i 1)))))
  159.         (port-misc-set! port new-str)))
  160.     (port-pos-set! port new-pos)
  161.     (let ((str (port-misc port)))
  162.       (let loop2 ((k (##fixnum.- l 1)))
  163.         (if (##not (##fixnum.< k 0))
  164.           (begin
  165.             (##string-set! str
  166.                            (##fixnum.+ pos k)
  167.                            (##string-ref s (##fixnum.+ i k)))
  168.             (loop2 (##fixnum.- k 1))))))
  169.     #f))
  170.  
  171. (define (##get-output-string port)
  172.   (let ((str (##substring (port-misc port) 0 (port-pos port))))
  173.     (port-pos-set! port 0)
  174.     str))
  175.  
  176. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  177.  
  178. (define (##close-port port)
  179.   (if (and (##not (##fixnum.< 3 (port-kind port)))
  180.            ((port-close port) port))
  181.     (port-kind-set! port (##fixnum.+ (##fixnum.modulo (port-kind port) 4) 4)))
  182.   #f)
  183.  
  184. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  185.  
  186. (define (##read-char port)
  187.   (let ((c (##peek-char port)))
  188.     (port-pos-set! port (##fixnum.+ (port-pos port) 1))
  189.     c))
  190.  
  191. (define (##peek-char port)
  192.   (let ((pos  (port-pos port))
  193.         (len  (port-len port))
  194.         (rbuf (port-rbuf port)))
  195.     (if (##fixnum.< pos len)
  196.       (##string-ref rbuf pos)
  197.       (if ((port-read port) port)
  198.         ##eof-object
  199.         (##peek-char port)))))
  200.  
  201. (define (##eof-object? x)
  202.   (##eq? x ##eof-object))
  203.  
  204. (define (##char-ready? port)
  205.   (let ((pos (port-pos port))
  206.         (len (port-len port)))
  207.     (if (##fixnum.< pos len)
  208.       #t
  209.       ((port-ready port) port))))
  210.  
  211. (define (##write-char c port)
  212.   (let ((wbuf (port-wbuf port)))
  213.     (##string-set! wbuf 0 c)
  214.     ((port-write port) wbuf 0 1 port)
  215.     #f))
  216.  
  217. (define (##write-string s port)
  218.   ((port-write port) s 0 (##string-length s) port)
  219.   #f)
  220.  
  221. (define (##write-substring s i j port)
  222.   (if (##fixnum.< i j) ((port-write port) s i j port))
  223.   #f)
  224.  
  225. (define (##newline port)
  226.   (##write-char #\newline port))
  227.  
  228. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  229.  
  230. (define (##read port)
  231.  
  232.   (##define-macro (+ . args)                `(##fixnum.+ ,@args))
  233.   (##define-macro (= . args)                `(##fixnum.= ,@args))
  234.   (##define-macro (< . args)                `(##fixnum.< ,@args))
  235.   (##define-macro (assq . args)             `(##assq ,@args))
  236.   (##define-macro (cdr . args)              `(##cdr ,@args))
  237.   (##define-macro (char->integer . args)    `(##char->integer ,@args))
  238.   (##define-macro (char-alphabetic? . args) `(##char-alphabetic? ,@args))
  239.   (##define-macro (char-downcase . args)    `(##char-downcase ,@args))
  240.   (##define-macro (char=? . args)           `(##char=? ,@args))
  241.   (##define-macro (cons . args)             `(##cons ,@args))
  242.   (##define-macro (set-cdr! . args)         `(##set-cdr! ,@args))
  243.   (##define-macro (eof-object? . args)      `(##eof-object? ,@args))
  244.   (##define-macro (list . args)             `(##list ,@args))
  245.   (##define-macro (make-string . args)      `(##make-string ,@args))
  246.   (##define-macro (make-vector . args)      `(##make-vector ,@args))
  247.   (##define-macro (not . args)              `(##not ,@args))
  248.   (##define-macro (string->number . args)   `(##string->number ,@args))
  249.   (##define-macro (string-set! . args)      `(##string-set! ,@args))
  250.   (##define-macro (vector-ref . args)       `(##vector-ref ,@args))
  251.   (##define-macro (vector-set! . args)      `(##vector-set! ,@args))
  252.  
  253.   (##define-macro (sf->locat sf)                #f)
  254.   (##define-macro (sf-peek-char sf)             `(##peek-char ,sf))
  255.   (##define-macro (sf-read-char sf)             `(##read-char ,sf))
  256.   (##define-macro (sf-read-error sf msg . args) `(##signal '##SIGNAL.READ-ERROR ,msg ,@args))
  257.   (##define-macro (make-source x locat)         x)
  258.   (##define-macro (source-code-set! source x)   x)
  259.   (##define-macro (string->canonical-symbol s)  `(##string->symbol ,s))
  260.  
  261.   (define QUOTE-sym            'quote)
  262.   (define QUASIQUOTE-sym       'quasiquote)
  263.   (define UNQUOTE-sym          'unquote)
  264.   (define UNQUOTE-SPLICING-sym 'unquote-splicing)
  265.  
  266.   (define char-newline #\newline)
  267.   (define false-object #f)
  268.  
  269.   (define named-char-table ##named-char-table)
  270.   (define read-table       ##read-table)
  271.  
  272. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  273.  
  274. ; For compatibility, `read-source' is the same reader as the one used in the
  275. ; compiler.  It has been copied from the file "gambit/compiler/source.scm".
  276.  
  277. (define (read-source sf)
  278.  
  279.   (define (read-char*)
  280.     (let ((c (sf-read-char sf)))
  281.       (if (eof-object? c)
  282.         (sf-read-error sf "Premature end of file encountered")
  283.         c)))
  284.  
  285.   (define (read-non-whitespace-char)
  286.     (let ((c (read-char*)))
  287.       (cond ((< 0 (vector-ref read-table (char->integer c)))
  288.              (read-non-whitespace-char))
  289.             ((char=? c #\;)
  290.              (let loop ()
  291.                (if (not (char=? (read-char*) char-newline))
  292.                  (loop)
  293.                  (read-non-whitespace-char))))
  294.             (else
  295.              c))))
  296.  
  297.   (define (delimiter? c)
  298.     (or (eof-object? c)
  299.         (not (= (vector-ref read-table (char->integer c)) 0))))
  300.  
  301.   (define (read-list first)
  302.     (let ((result (cons first '())))
  303.       (let loop ((end result))
  304.         (let ((c (read-non-whitespace-char)))
  305.           (cond ((char=? c #\)))
  306.                 ((and (char=? c #\.) (delimiter? (sf-peek-char sf)))
  307.                  (let ((x (read-source sf)))
  308.                    (if (char=? (read-non-whitespace-char) #\))
  309.                      (set-cdr! end x)
  310.                      (sf-read-error sf "')' expected"))))
  311.                 (else
  312.                  (let ((tail (cons (rd* c) '())))
  313.                    (set-cdr! end tail)
  314.                    (loop tail))))))
  315.       result))
  316.  
  317.   (define (read-vector)
  318.     (define (loop i)
  319.       (let ((c (read-non-whitespace-char)))
  320.         (if (char=? c #\))
  321.           (make-vector i '())
  322.           (let* ((x (rd* c))
  323.                  (v (loop (+ i 1))))
  324.             (vector-set! v i x)
  325.             v))))
  326.     (loop 0))
  327.  
  328.   (define (read-string)
  329.     (define (loop i)
  330.       (let ((c (read-char*)))
  331.         (cond ((char=? c #\")
  332.                (make-string i #\space))
  333.               ((char=? c #\\)
  334.                (let* ((c (read-char*))
  335.                       (s (loop (+ i 1))))
  336.                  (string-set! s i c)
  337.                  s))
  338.               (else
  339.                (let ((s (loop (+ i 1))))
  340.                  (string-set! s i c)
  341.                  s)))))
  342.     (loop 0))
  343.  
  344.   (define (read-symbol/number-string i)
  345.     (if (delimiter? (sf-peek-char sf))
  346.       (make-string i #\space)
  347.       (let* ((c (sf-read-char sf))
  348.              (s (read-symbol/number-string (+ i 1))))
  349.         (string-set! s i (char-downcase c))
  350.         s)))
  351.  
  352.   (define (read-symbol/number c)
  353.     (let ((s (read-symbol/number-string 1)))
  354.       (string-set! s 0 (char-downcase c))
  355.       (or (string->number s 10)
  356.           (string->canonical-symbol s))))
  357.  
  358.   (define (read-prefixed-number c)
  359.     (let ((s (read-symbol/number-string 2)))
  360.       (string-set! s 0 #\#)
  361.       (string-set! s 1 c)
  362.       (string->number s 10)))
  363.  
  364.   (define (read-special-symbol)
  365.     (let ((s (read-symbol/number-string 2)))
  366.       (string-set! s 0 #\#)
  367.       (string-set! s 1 #\#)
  368.       (string->canonical-symbol s)))
  369.  
  370.   (define (rd c)
  371.     (cond ((eof-object? c)
  372.            c)
  373.           ((< 0 (vector-ref read-table (char->integer c)))
  374.            (rd (sf-read-char sf)))
  375.           ((char=? c #\;)
  376.            (let loop ()
  377.              (let ((c (sf-read-char sf)))
  378.                (cond ((eof-object? c)
  379.                       c)
  380.                      ((char=? c char-newline)
  381.                       (rd (sf-read-char sf)))
  382.                      (else
  383.                       (loop))))))
  384.           (else
  385.            (rd* c))))
  386.  
  387.   (define (rd* c)
  388.     (let ((source (make-source #f (sf->locat sf))))
  389.       (source-code-set!
  390.         source
  391.         (cond ((char=? c #\()
  392.                (let ((x (read-non-whitespace-char)))
  393.                  (if (char=? x #\))
  394.                    '()
  395.                    (read-list (rd* x)))))
  396.               ((char=? c #\#)
  397.                (let ((c (char-downcase (sf-read-char sf))))
  398.                  (cond ((char=? c #\() (read-vector))
  399.                        ((char=? c #\f) false-object)
  400.                        ((char=? c #\t) #t)
  401.                        ((char=? c #\\)
  402.                         (let ((c (read-char*)))
  403.                           (if (or (not (char-alphabetic? c))
  404.                                   (delimiter? (sf-peek-char sf)))
  405.                             c
  406.                             (let ((name (read-symbol/number c)))
  407.                               (let ((x (assq name named-char-table)))
  408.                                 (if x
  409.                                   (cdr x)
  410.                                   (sf-read-error sf "Unknown character name:" name)))))))
  411.  
  412.                        ((char=? c #\#)
  413.                         (read-special-symbol))
  414.                        (else
  415.                         (let ((num (read-prefixed-number c)))
  416.                           (or num
  417.                               (sf-read-error sf "Unknown '#' read macro:" c)))))))
  418.               ((char=? c #\")
  419.                (read-string))
  420.               ((char=? c #\')
  421.                (list (make-source QUOTE-sym (sf->locat sf))
  422.                      (read-source sf)))
  423.               ((char=? c #\`)
  424.                (list (make-source QUASIQUOTE-sym (sf->locat sf))
  425.                      (read-source sf)))
  426.               ((char=? c #\,)
  427.                (if (char=? (sf-peek-char sf) #\@)
  428.                  (let ((x (make-source UNQUOTE-SPLICING-sym (sf->locat sf))))
  429.                    (sf-read-char sf)
  430.                    (list x (read-source sf)))
  431.                  (list (make-source UNQUOTE-sym (sf->locat sf))
  432.                        (read-source sf))))
  433.               ((char=? c #\))
  434.                (sf-read-error sf "Misplaced ')'"))
  435.               (else
  436.                (if (char=? c #\.)
  437.                  (if (delimiter? (sf-peek-char sf))
  438.                    (sf-read-error sf "Misplaced '.'")))
  439.                (read-symbol/number c))))))
  440.  
  441.   (rd (sf-read-char sf)))
  442.  
  443. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  444.  
  445.   (read-source port))
  446.  
  447. (define ##named-char-table #f)
  448. (set! ##named-char-table
  449.   (##list (##cons 'nul     (##integer->char 0))
  450.           (##cons 'tab     (##integer->char 9))
  451.           (##cons 'newline (##integer->char 10))
  452.           (##cons 'space   (##integer->char 32))))
  453.  
  454. (define ##read-table #f)
  455. (set! ##read-table
  456.   (let ((rt (##make-vector 256 0)))
  457.  
  458.     ; setup whitespace chars
  459.  
  460.     (let loop ((i 32))
  461.       (if (##not (##fixnum.< i 0))
  462.         (begin (##vector-set! rt i 1) (loop (##fixnum.- i 1)))))
  463.  
  464.     ; setup other delimiters
  465.  
  466.     (##vector-set! rt (##char->integer #\;) -1)
  467.     (##vector-set! rt (##char->integer #\() -1)
  468.     (##vector-set! rt (##char->integer #\)) -1)
  469.     (##vector-set! rt (##char->integer #\") -1)
  470.     (##vector-set! rt (##char->integer #\') -1)
  471.     (##vector-set! rt (##char->integer #\`) -1)
  472.  
  473.     rt))
  474.  
  475. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  476.  
  477. (define (##wr-unlimited obj port display? touch?)
  478.   (##fixnum.- (max-fixnum)
  479.               (##wr obj port display? touch? (max-fixnum))))
  480.  
  481. (define (##wr-limited obj port display? touch? limit)
  482.   (##fixnum.- limit
  483.               (##wr obj port display? touch? limit)))
  484.  
  485. (define (##wr obj port display? touch? limit)
  486.   (if (##fixnum.< 0 limit)
  487.     ((##vector-ref ##wr-type-table (##type obj))
  488.      obj
  489.      port
  490.      display?
  491.      touch?
  492.      limit)
  493.     0))
  494.  
  495. (define (##wr-str s port limit)
  496.   (##wr-substr s 0 (##string-length s) port limit))
  497.  
  498. (define (##wr-substr s i j port limit)
  499.   (let ((len (##fixnum.- j i)))
  500.     (if (##fixnum.< limit len)
  501.       (begin
  502.         (##write-substring s i (##fixnum.+ i limit) port)
  503.         0)
  504.       (begin
  505.         (##write-substring s i j port)
  506.         (##fixnum.- limit len)))))
  507.  
  508. (define (##wr-ch c port limit)
  509.   (if (##fixnum.< 0 limit)
  510.     (begin
  511.       (##write-char c port)
  512.       (##fixnum.- limit 1))
  513.     0))
  514.  
  515. (define (##wr-adr type obj port limit)
  516.   (##wr-str "]" port
  517.             (##wr-str (##number->string (##type-cast obj (type-fixnum)) 16) port
  518.                       (##wr-str " #x" port
  519.                                 (##wr-str type port
  520.                                           (##wr-str "#[" port limit))))))
  521.  
  522. (define (##wr-tag-in type tag name port limit)
  523.   (##wr-str "]" port
  524.             (##wr name port #f #f
  525.                   (##wr-str " in " port
  526.                             (##wr-str tag port
  527.                                       (##wr-str " " port
  528.                                                 (##wr-str type port
  529.                                                           (##wr-str "#[" port limit))))))))
  530.  
  531. (define (##wr-named type name port limit)
  532.   (##wr-str "]" port
  533.             (##wr name port #f #f
  534.                   (##wr-str " " port
  535.                             (##wr-str type port
  536.                                       (##wr-str "#[" port limit))))))
  537.  
  538. (define ##wr-type-table
  539.   (##make-vector (type-range)
  540.     (lambda (obj port display? touch? limit)
  541.       (##wr-adr (##string-append "type-"
  542.                                  (##number->string (##type obj) 10))
  543.                 obj
  544.                 port
  545.                 limit))))
  546.  
  547. (define ##wr-subtype-table
  548.   (##make-vector (subtype-range)
  549.     (lambda (obj port display? touch? limit)
  550.       (##wr-adr (##string-append "subtype-"
  551.                                  (##number->string (##subtype obj) 10))
  552.                 obj
  553.                 port
  554.                 limit))))
  555.  
  556. ; Setup type dispatch table
  557.  
  558. (##vector-set! ##wr-type-table (type-fixnum)
  559.   (lambda (obj port display? touch? limit)
  560.     (##wr-str (##number->string obj 10) port limit)))
  561.  
  562. (##vector-set! ##wr-type-table (type-special)
  563.   (lambda (obj port display? touch? limit)
  564.  
  565.     (define (assq-cdr x l)
  566.       (let loop ((y l))
  567.         (if (##pair? y)
  568.           (let ((couple (##car y)))
  569.             (if (##eq? x (##cdr couple)) couple (loop (##cdr y))))
  570.             #f)))
  571.  
  572.     (if (##char? obj)
  573.  
  574.       (if display?
  575.         (##wr-ch obj port limit)
  576.         (let ((x (assq-cdr obj ##named-char-table)))
  577.           (if x
  578.            (##wr-str (symbol-string (##car x)) port
  579.                      (##wr-str "#\\" port limit))
  580.            (##wr-ch obj port
  581.                     (##wr-str "#\\" port limit)))))
  582.  
  583.       (cond ((##eq? obj #t)
  584.              (##wr-str "#t" port limit))
  585.             ((##eq? obj #f)
  586.              (##wr-str "#f" port limit))
  587.             ((##eq? obj '())
  588.              (##wr-str "()" port limit))
  589.             ((##eq? obj ##undef-object)
  590.              (##wr-str "#[undefined]" port limit))
  591.             ((##eq? obj ##unass-object)
  592.              (##wr-str "#[unassigned]" port limit))
  593.             ((##eq? obj ##unbound-object)
  594.              (##wr-str "#[unbound]" port limit))
  595.             ((##eq? obj ##eof-object)
  596.              (##wr-str "#[eof]" port limit))
  597.             (else
  598.              (##wr-adr "special" obj port limit))))))
  599.  
  600. (##vector-set! ##wr-type-table (type-pair)
  601.   (lambda (obj port display? touch? limit)
  602.  
  603.     (define (wr-tail l limit)
  604.       (if (##fixnum.< 0 limit)
  605.         (let ((l (if touch? (touch-vars (l) l) l)))
  606.           (cond ((##pair? l)
  607.                  (wr-tail (##cdr l)
  608.                           (##wr (##car l) port display? touch?
  609.                                 (##wr-str " " port limit))))
  610.                 ((##null? l)
  611.                  (##wr-str ")" port limit))
  612.                 (else
  613.                  (##wr-str ")" port
  614.                            (##wr l port display? touch?
  615.                                  (##wr-str " . " port limit))))))
  616.         0))
  617.  
  618.     (define (wr-list x y limit)
  619.       (wr-tail y
  620.                (##wr x port display? touch?
  621.                      (##wr-str "(" port limit))))
  622.  
  623.     (let ((x (##car obj))
  624.           (y (##cdr obj)))
  625.       (if (and (##pair? y) (##null? (##cdr y)))
  626.         (let ((z (##car y)))
  627.           (case x
  628.             ((QUOTE)
  629.              (##wr z port display? touch?
  630.                    (##wr-str "'" port limit)))
  631.             ((QUASIQUOTE)
  632.              (##wr z port display? touch?
  633.                    (##wr-str "`" port limit)))
  634.             ((UNQUOTE)
  635.              (##wr z port display? touch?
  636.                    (##wr-str "," port limit)))
  637.             ((UNQUOTE-SPLICING)
  638.              (##wr z port display? touch?
  639.                    (##wr-str ",@" port limit)))
  640.             (else
  641.              (wr-list x y limit))))
  642.         (wr-list x y limit)))))
  643.  
  644. (##vector-set! ##wr-type-table (type-weak-pair)
  645.   (lambda (obj port display? touch? limit)
  646.     (##wr-adr "weak-pair" obj port limit)))
  647.  
  648. (##vector-set! ##wr-type-table (type-subtyped)
  649.   (lambda (obj port display? touch? limit)
  650.     ((##vector-ref ##wr-subtype-table (##subtype obj))
  651.      obj
  652.      port
  653.      display?
  654.      touch?
  655.      limit)))
  656.  
  657. (##vector-set! ##wr-type-table (type-procedure)
  658.   (lambda (obj port display? touch? limit)
  659.     (let ((name (##object->global-var-name obj)))
  660.       (if name
  661.         (##wr-named "procedure" name port limit)
  662.         (cond ((##proc-closure? obj)
  663.                (##wr-adr "procedure" obj port limit))
  664.               ((##proc-subproc? obj)
  665.                (let ((parent (##object->global-var-name (##proc-subproc-parent obj))))
  666.                  (if parent
  667.                    (##wr-tag-in "subprocedure" (##number->string (##proc-subproc-tag obj) 10) parent port limit)
  668.                    (##wr-adr "procedure" obj port limit))))
  669.               (else
  670.                (##wr-adr "procedure" obj port limit)))))))
  671.  
  672. (##vector-set! ##wr-type-table (type-placeholder)
  673.   (lambda (obj port display? touch? limit)
  674.     (if touch?
  675.       (touch-vars (obj)
  676.         (##wr obj port display? touch? limit))
  677.       (##wr-adr "placeholder" obj port limit))))
  678.  
  679. ; Setup subtype dispatch table
  680.  
  681. (##vector-set! ##wr-subtype-table (subtype-vector)
  682.   (lambda (obj port display? touch? limit)
  683.     (##wr (##vector->list obj) port display? touch?
  684.           (##wr-str "#" port limit))))
  685.  
  686. (##vector-set! ##wr-subtype-table (subtype-symbol)
  687.   (lambda (obj port display? touch? limit)
  688.     (##wr-str (symbol-string obj) port limit)))
  689.  
  690. (##vector-set! ##wr-subtype-table (subtype-port)
  691.   (lambda (obj port display? touch? limit)
  692.     (##wr-named (if (##input-port? obj)
  693.                   (if (##output-port? obj) "input-output-port" "input-port")
  694.                   "output-port")
  695.                 (port-name obj)
  696.                 port
  697.                 limit)))
  698.  
  699. (##vector-set! ##wr-subtype-table (subtype-ratnum)
  700.   (lambda (obj port display? touch? limit)
  701.     (##wr-str (##number->string obj 10) port limit)))
  702.     
  703. (##vector-set! ##wr-subtype-table (subtype-cpxnum)
  704.   (lambda (obj port display? touch? limit)
  705.     (##wr-str (##number->string obj 10) port limit)))
  706.  
  707. (##vector-set! ##wr-subtype-table (subtype-frame)
  708.   (lambda (obj port display? touch? limit)
  709.     (##wr-adr "frame" obj port limit)))
  710.  
  711. (##vector-set! ##wr-subtype-table (subtype-task)
  712.   (lambda (obj port display? touch? limit)
  713.     (##wr-adr "task" obj port limit)))
  714.  
  715. (##vector-set! ##wr-subtype-table (subtype-queue)
  716.   (lambda (obj port display? touch? limit)
  717.     (##wr-adr "queue" obj port limit)))
  718.  
  719. (##vector-set! ##wr-subtype-table (subtype-semaphore)
  720.   (lambda (obj port display? touch? limit)
  721.     (##wr-adr "semaphore" obj port limit)))
  722.  
  723. (##vector-set! ##wr-subtype-table (subtype-string)
  724.   (lambda (obj port display? touch? limit)
  725.  
  726.     (define (wr-str-quoted s port limit)
  727.       (let loop ((i 0) (j 0) (limit limit))
  728.         (if (##fixnum.< j (##string-length s))
  729.           (let ((c (##string-ref s j)))
  730.             (if (or (##char=? c #\") (##char=? c #\\))
  731.               (loop j
  732.                     (##fixnum.+ j 1)
  733.                     (##wr-str "\\" port
  734.                               (##wr-substr s i j port limit)))
  735.               (loop i (##fixnum.+ j 1) limit)))
  736.           (##wr-substr s i j port limit))))
  737.  
  738.     (if display?
  739.       (##wr-str obj port limit)
  740.       (##wr-str "\"" port
  741.                 (wr-str-quoted obj port
  742.                                (##wr-str "\"" port limit))))))
  743.  
  744. (##vector-set! ##wr-subtype-table (subtype-bignum)
  745.   (lambda (obj port display? touch? limit)
  746.     (##wr-str (##number->string obj 10) port limit)))
  747.  
  748. (##vector-set! ##wr-subtype-table (subtype-flonum)
  749.   (lambda (obj port display? touch? limit)
  750.     (##wr-str (##number->string obj 10) port limit)))
  751.  
  752. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  753.  
  754. (define (##write obj port touch?)
  755.   (##wr-unlimited obj port #f touch?))
  756.  
  757. (define (##display obj port touch?)
  758.   (##wr-unlimited obj port #t touch?))
  759.  
  760. (define (##pretty obj port touch? col width)
  761.  
  762.   (define (spaces n port)
  763.     (if (##fixnum.< 0 n)
  764.       (let ((m (if (##fixnum.< 40 n) 40 n)))
  765.         (##write-substring "                                        " 0 m port)
  766.         (spaces (##fixnum.- n m) port))))
  767.  
  768.   (define (indent to from port)
  769.     (if (##fixnum.< to from)
  770.       (begin
  771.         (##newline port)
  772.         (spaces to port))
  773.       (spaces (##fixnum.- to from) port)))
  774.  
  775.   (define (obj->string obj width touch?)
  776.     (let ((port (##open-output-string)))
  777.       (##wr-limited obj port #f touch? (##fixnum.+ width 1))
  778.       (let* ((str (##get-output-string port))
  779.              (len (##string-length str)))
  780.         (##close-port port)
  781.         (if (##fixnum.< width len) #f str))))
  782.  
  783.   (define (p obj port touch? col width extra pp-pair)
  784.     (let ((obj (if touch? (touch-vars (obj) obj))))
  785.       (if (or (##pair? obj) (##vector? obj))
  786.         (let ((str (obj->string obj (##fixnum.- (##fixnum.- width col) extra) touch?)))
  787.           (if str
  788.             (begin
  789.               (##write-string str port)
  790.               (##fixnum.+ col (##string-length str)))
  791.             (if (##pair? obj)
  792.               (pp-pair obj port touch? col width extra)
  793.               (let ((col* (##fixnum.+ col 1))
  794.                     (elems (##vector->list obj)))
  795.                 (##write-string "#" port)
  796.                 (pp-list elems port touch? col* width extra pp-expr)))))
  797.         (##fixnum.+ col (##write obj port touch?)))))
  798.  
  799.   (define (pp-expr expr port touch? col width extra)
  800.     (let ((head (##car expr)))
  801.       (let* ((head (if touch? (touch-vars (head) head) head))
  802.              (style (pp-style head)))
  803.         (if style
  804.           (style expr port touch? col width extra)
  805.           (if (##symbol? head)
  806.             (if (##fixnum.< (##string-length (symbol-string head)) 8)
  807.               (pp-call expr port touch? col width extra pp-expr)
  808.               (pp-general expr port touch? col width extra #f #f #f pp-expr))
  809.             (pp-list expr port touch? col width extra pp-expr))))))
  810.  
  811.   ; (head item1
  812.   ;       item2
  813.   ;       item3)
  814.   (define (pp-call expr port touch? col width extra pp-item)
  815.     (##write-string "(" port)
  816.     (let* ((head (##car expr))
  817.            (rest (##cdr expr))
  818.            (col* (##fixnum.+ (##fixnum.+ col 1) (##write head port touch?))))
  819.       (pp-down rest port touch? col* (##fixnum.+ col* 1) width extra pp-item)))
  820.  
  821.   ; (item1
  822.   ;  item2
  823.   ;  item3)
  824.   (define (pp-list l port touch? col width extra pp-item)
  825.     (##write-string "(" port)
  826.     (let ((col* (##fixnum.+ col 1)))
  827.       (pp-down l port touch? col* col* width extra pp-item)))
  828.  
  829.   (define (pp-down l port touch? col1 col2 width extra pp-item)
  830.     (let loop ((l l) (col* col1))
  831.       (if (##pair? l)
  832.         (let ((rest (##cdr l)))
  833.           (let* ((rest (if touch? (touch-vars (rest) rest) rest))
  834.                  (extra* (if (##null? rest) (##fixnum.+ extra 1) 0)))
  835.             (indent col2 col* port)
  836.             (loop rest (p (##car l) port touch? col2 width extra* pp-item))))
  837.         (if (##null? l)
  838.           (begin
  839.             (##write-string ")" port)
  840.             (##fixnum.+ col* 1))
  841.           (begin
  842.             (indent col2 col* port)
  843.             (##write-string "." port)
  844.             (indent col2 col* port)
  845.             (let* ((extra* (##fixnum.+ extra 1))
  846.                    (col** (p l port touch? col2 width extra* pp-item)))
  847.               (##write-string ")" port)
  848.               (##fixnum.+ col** 1)))))))
  849.  
  850.   (define (pp-expr-list l port touch? col width extra)
  851.     (pp-list l port touch? col width extra pp-expr))
  852.  
  853.   (define (pp-abbrev expr port touch? col width extra prefix)
  854.     (let* ((rest (##cdr expr))
  855.            (rest (if touch? (touch-vars (rest) rest) rest)))
  856.       (if (and (##pair? rest) (##null? (##cdr rest)))
  857.         (let ((col* (##fixnum.+ col (##string-length prefix))))
  858.           (##write-string prefix port)
  859.           (p (##car rest) port touch? col* width extra pp-expr))
  860.         (pp-call expr port touch? col width extra pp-expr))))
  861.  
  862.   (define (pp-general expr port touch? col width extra named? pp-1 pp-2 pp-3)
  863.  
  864.     (define (tail1 rest col1 col2 col3)
  865.       (if (and pp-1 (##pair? rest))
  866.         (begin
  867.           (indent col3 col2 port)
  868.           (let* ((val1 (##car rest))
  869.                  (rest (##cdr rest))
  870.                  (rest (if touch? (touch-vars (rest) rest) rest))
  871.                  (extra* (if (##null? rest) (##fixnum.+ extra 1) 0))
  872.                  (col* (p val1 port touch? col3 width extra* pp-1)))
  873.             (tail2 rest col1 col* col3)))
  874.         (tail2 rest col1 col2 col3)))
  875.  
  876.     (define (tail2 rest col1 col2 col3)
  877.       (if (and pp-2 (##pair? rest))
  878.         (begin
  879.           (indent col3 col2 port)
  880.           (let* ((val1 (##car rest))
  881.                  (rest (##cdr rest))
  882.                  (rest (if touch? (touch-vars (rest) rest) rest))
  883.                  (extra* (if (##null? rest) (##fixnum.+ extra 1) 0))
  884.                  (col* (p val1 port touch? col3 width extra* pp-2)))
  885.             (tail3 rest col1 col*)))
  886.         (tail3 rest col1 col2)))
  887.  
  888.     (define (tail3 rest col1 col2)
  889.       (pp-down rest port touch? col2 col1 width extra pp-3))
  890.  
  891.     (##write-string "(" port)
  892.     (let* ((head (##car expr))
  893.            (rest (##cdr expr))
  894.            (rest (if touch? (touch-vars (rest) rest) rest))
  895.            (col* (##fixnum.+ (##fixnum.+ col 1) (##write head port touch?))))
  896.       (if (and named? (##pair? rest))
  897.         (begin
  898.           (##write-string " " port)
  899.           (let* ((name (##car rest))
  900.                  (rest (##cdr rest))
  901.                  (rest (if touch? (touch-vars (rest) rest) rest))
  902.                  (col** (##fixnum.+ (##fixnum.+ col* 1) (##write name port touch?))))
  903.             (tail1 rest (##fixnum.+ col 2) col** (##fixnum.+ col** 1))))
  904.         (tail1 rest (##fixnum.+ col 2) col* (##fixnum.+ col* 1)))))
  905.  
  906.   (define (pp-quote expr port touch? col width extra)
  907.     (pp-abbrev expr port touch? col width extra "'"))
  908.  
  909.   (define (pp-quasiquote expr port touch? col width extra)
  910.     (pp-abbrev expr port touch? col width extra "`"))
  911.  
  912.   (define (pp-unquote expr port touch? col width extra)
  913.     (pp-abbrev expr port touch? col width extra ","))
  914.  
  915.   (define (pp-unquote-splicing expr port touch? col width extra)
  916.     (pp-abbrev expr port touch? col width extra ",@"))
  917.  
  918.   (define (pp-lambda expr port touch? col width extra)
  919.     (pp-general expr port touch? col width extra #f pp-expr-list #f pp-expr))
  920.  
  921.   (define (pp-if expr port touch? col width extra)
  922.     (pp-general expr port touch? col width extra #f pp-expr #f pp-expr))
  923.  
  924.   (define (pp-set! expr port touch? col width extra)
  925.     (pp-general expr port touch? col width extra #f pp-expr #f pp-expr))
  926.  
  927.   (define (pp-cond expr port touch? col width extra)
  928.     (pp-call expr port touch? col width extra pp-expr-list))
  929.  
  930.   (define (pp-case expr port touch? col width extra)
  931.     (pp-general expr port touch? col width extra #f pp-expr #f pp-expr-list))
  932.  
  933.   (define (pp-and expr port touch? col width extra)
  934.     (pp-call expr port touch? col width extra pp-expr))
  935.  
  936.   (define (pp-or expr port touch? col width extra)
  937.     (pp-call expr port touch? col width extra pp-expr))
  938.  
  939.   (define (pp-let expr port touch? col width extra)
  940.     (let* ((rest (##cdr expr))
  941.            (rest (if touch? (touch-vars (rest) rest) rest))
  942.            (named? (and (##pair? rest) (##symbol? (##car rest)))))
  943.       (pp-general expr port touch? col width extra named? pp-expr-list #f pp-expr)))
  944.  
  945.   (define (pp-let* expr port touch? col width extra)
  946.     (pp-general expr port touch? col width extra #f pp-expr-list #f pp-expr))
  947.  
  948.   (define (pp-letrec expr port touch? col width extra)
  949.     (pp-general expr port touch? col width extra #f pp-expr-list #f pp-expr))
  950.  
  951.   (define (pp-begin expr port touch? col width extra)
  952.     (pp-general expr port touch? col width extra #f #f #f pp-expr))
  953.  
  954.   (define (pp-do expr port touch? col width extra)
  955.     (pp-general expr port touch? col width extra #f pp-expr-list pp-expr-list pp-expr))
  956.  
  957.   (define (pp-define expr port touch? col width extra)
  958.     (pp-general expr port touch? col width extra #f pp-expr-list #f pp-expr))
  959.  
  960.   (define (pp-style x)
  961.     (case x
  962.       ((quote) pp-quote)
  963.       ((quasiquote) pp-quasiquote)
  964.       ((unquote) pp-unquote)
  965.       ((unquote-splicing) pp-unquote-splicing)
  966.       ((lambda) pp-lambda)
  967.       ((if) pp-if)
  968.       ((set!) pp-set!)
  969.       ((cond) pp-cond)
  970.       ((case) pp-case)
  971.       ((and) pp-and)
  972.       ((or) pp-or)
  973.       ((let) pp-let)
  974.       ((let*) pp-let*)
  975.       ((letrec) pp-letrec)
  976.       ((begin) pp-begin)
  977.       ((do) pp-do)
  978.       ((define) pp-define)
  979.       (else #f)))
  980.  
  981.   (p obj port touch? col width 0 pp-expr))
  982.  
  983. (define (##pretty-print obj port width)
  984.   (##pretty obj port (if-touches #t #f) 0 width)
  985.   (##newline port))
  986.  
  987. (define (##object->string obj width touch?)
  988.   (let ((port (##open-output-string)))
  989.     (##wr-limited obj port #f touch? (##fixnum.+ width 1))
  990.     (let* ((str (##get-output-string port))
  991.            (len (##string-length str)))
  992.       (##close-port port)
  993.       (if (##fixnum.< width len)
  994.         (begin
  995.           (##string-set! str (##fixnum.- width 1) #\.)
  996.           (##string-set! str (##fixnum.- width 2) #\.)
  997.           (##string-set! str (##fixnum.- width 3) #\.)
  998.           (##string-shrink! str width)
  999.           str)
  1000.         str))))
  1001.  
  1002. (define (##format port str . args)
  1003.   (let ((len (##string-length str)))
  1004.     (let loop ((i 0) (j 0) (args args))
  1005.       (if (##not (##fixnum.< j len))
  1006.         (##write-substring str i j port)
  1007.         (let ((c (##string-ref str j)))
  1008.           (if (##char=? c #\~)
  1009.             (let ((c (##string-ref str (##fixnum.+ j 1))))
  1010.               (##write-substring str i j port)
  1011.               (if (##memq c '(#\A #\S #\V #\D #\B #\O #\X))
  1012.                 (let ((arg (##car args))
  1013.                       (rest (##cdr args)))
  1014.                   (cond ((##char=? c #\A)
  1015.                          (##display arg port #t))
  1016.                         ((##char=? c #\S)
  1017.                          (##write arg port #t))
  1018.                         ((##char=? c #\V)
  1019.                          (##wr-unlimited arg port #f #f))
  1020.                         ((##char=? c #\D)
  1021.                          (##write-string (##number->string arg 10) port))
  1022.                         ((##char=? c #\B)
  1023.                          (##write-string (##number->string arg 2) port))
  1024.                         ((##char=? c #\O)
  1025.                          (##write-string (##number->string arg 8) port))
  1026.                         ((##char=? c #\X)
  1027.                          (##write-string (##number->string arg 16) port)))
  1028.                   (loop (##fixnum.+ j 2) (##fixnum.+ j 2) rest))
  1029.                 (cond ((##char=? c #\%)
  1030.                        (##newline port)
  1031.                        (loop (##fixnum.+ j 2) (##fixnum.+ j 2) args))
  1032.                       ((##char=? c #\~)
  1033.                        (##write-string "~" port)
  1034.                        (loop (##fixnum.+ j 2) (##fixnum.+ j 2) args))
  1035.                       ((##char=? c #\newline)
  1036.                        (let ((k (let skip ((j (##fixnum.+ j 2)))
  1037.                                   (cond ((##not (##fixnum.< j len))
  1038.                                          j)
  1039.                                         ((##char-whitespace? c)
  1040.                                          (skip (##fixnum.+ j 1)))
  1041.                                         (else
  1042.                                          j)))))
  1043.                          (loop k k args)))
  1044.                       (else
  1045.                        (loop (##fixnum.+ j 2) (##fixnum.+ j 2) args)))))
  1046.             (loop i (##fixnum.+ j 1) args)))))))
  1047.  
  1048. ;------------------------------------------------------------------------------
  1049.  
  1050. (define (##stdin-read descr rbuf i j)
  1051.   (let ((len (##os-file-read descr rbuf i j)))
  1052.     (if len
  1053.       (let ((p ##transcript-port))
  1054.         (if (and (##fixnum.< 0 len)
  1055.                  (##output-port? p)
  1056.                  (##not (##closed-port? p)))
  1057.           (##write-substring rbuf i j p))))
  1058.     len))
  1059.  
  1060. (define ##stdin
  1061.   (let ((port
  1062.           (##make-port 0 'STDIN 0
  1063.             ##stdin-read
  1064.             #f
  1065.             ##os-file-read-ready
  1066.             #f
  1067.             (##make-string 1 #\space)
  1068.             #f)))
  1069.     (port-close-set! port (lambda (port) (##os-file-close (port-misc port)) #f))
  1070.     port))
  1071.  
  1072. (define (##stdout-write descr s i j)
  1073.   (let ((len (##os-file-write descr s i j)))
  1074.     (if len
  1075.       (let ((p ##transcript-port))
  1076.         (if (and (##fixnum.< 0 len)
  1077.                  (##output-port? p)
  1078.                  (##not (##closed-port? p)))
  1079.           (##write-substring s i j p))))
  1080.     len))
  1081.  
  1082. (define ##stdout
  1083.   (let ((port
  1084.           (##make-port 1 'STDOUT 2
  1085.             #f
  1086.             ##stdout-write
  1087.             #f
  1088.             #f
  1089.             #f
  1090.             (##make-string 1 #\space))))
  1091.     (port-close-set! port (lambda (port) (##os-file-close (port-misc port)) #f))
  1092.     port))
  1093.  
  1094. (define ##stderr
  1095.   (let ((port
  1096.           (##make-port 2 'STDERR 2
  1097.             #f
  1098.             ##stdout-write
  1099.             #f
  1100.             #f
  1101.             #f
  1102.             (##make-string 1 #\space))))
  1103.     (port-close-set! port (lambda (port) (##os-file-close (port-misc port)) #f))
  1104.     port))
  1105.  
  1106. (define (##transcript-on port)
  1107.   (set! ##transcript-port port)
  1108.   #f)
  1109.  
  1110. (define (##transcript-off port)
  1111.   (set! ##transcript-port #f)
  1112.   #f)
  1113.  
  1114. (define ##transcript-port #f)
  1115.  
  1116. (define (##current-input-port)
  1117.   (##dynamic-ref '##CURRENT-INPUT-PORT ##stdin))
  1118.  
  1119. (define (##current-output-port)
  1120.   (##dynamic-ref '##CURRENT-OUTPUT-PORT ##stdout))
  1121.  
  1122. (define (##port-width port)
  1123.   (##dynamic-ref '##PORT-WIDTH 79))
  1124.  
  1125. ;------------------------------------------------------------------------------
  1126.  
  1127. (define (##load s trace-port)
  1128.  
  1129.   (define (load-from-port port)
  1130.     (let loop ()
  1131.       (let ((expr (##read port)))
  1132.         (if (##not (##eof-object? expr))
  1133.           (let ((val (##eval-global expr)))
  1134.             (if trace-port
  1135.               (begin
  1136.                 (##write val trace-port (if-touches #t #f))
  1137.                 (##newline trace-port)))
  1138.             (loop))
  1139.           (##close-port port)))))
  1140.  
  1141.   (define (remove-extension str ext)
  1142.     (let ((lstr (##string-length str))
  1143.           (lext (##string-length ext)))
  1144.       (cond ((##fixnum.< lstr lext)
  1145.              str)
  1146.             ((##string=? (##substring str (##fixnum.- lstr lext) lstr) ext)
  1147.              (##substring str 0 (##fixnum.- lstr lext)))
  1148.             (else
  1149.              str))))
  1150.  
  1151.   (let* ((name (remove-extension s ".O"))
  1152.          (name* (##string-append name ".O"))
  1153.          (port (##open-input-file name*)))
  1154.     (if port
  1155.       (begin
  1156.         (##close-port port)
  1157.         (let ((msg (##load-object-file name)))
  1158.           (if (##procedure? msg)
  1159.             (begin (msg) name*)
  1160.             (trap-load (load name*) msg))))
  1161.       (let* ((name (remove-extension s ".scm"))
  1162.              (name* (##string-append name ".scm"))
  1163.              (port (##open-input-file name*)))
  1164.         (if port
  1165.           (begin (load-from-port port) name*)
  1166.           (let ((port (##open-input-file s)))
  1167.             (if port
  1168.               (begin (load-from-port port) s)
  1169.               (trap-open-file (load s)))))))))
  1170.  
  1171. ;------------------------------------------------------------------------------
  1172.